'- samcoupe mode1 (8x8) image converter - (256x192 bmp 16c - 8/4bit) 20120326152420
'- based on qbasic version 0111300014

finp$="picture.png"

'- matrizes
dim graypl[16],celcnt[16],clrcnt[16]
dim opaletr[16],opaletg[16],opaletb[16]
dim npaletr[16],npaletg[16],npaletb[16]
dim realpal[16],xpnt(8,8),invrp[16]

tmfl$="_tmpr01.gif"
shell("convert "+finp$+" -colors 16 "+tmfl$)

loadimage(finp$,1):pasteicon(0,0,1)


open tmfl$ for input as #1
   for i=1 to 13:n=readbyte(1):next
   for i=0 to 15
      n=readbyte(1):npaletr[i]=int((int(n/32))*(255/7))
      n=readbyte(1):npaletg[i]=int((int(n/32))*(255/7))
      n=readbyte(1):npaletb[i]=int((int(n/32))*(255/7))
   next
 close #1

shell ("rm "+tmfl$)




' preenche matrizes opalet com a paleta do samcoupe
for i=0 to palsz-1
  ympos= 54+1+(i*4)
  get #1, ympos+1:j=int(asc(fb1$)/32):grky=j mod 2:opaletg[i]=j
  get #1, ympos:j=(int(asc(fb1$)/64)*2)+grky:opaletb[i]=j
  get #1, ympos+2:j=(int(asc(fb1$)/64)*2)+grky:opaletr[i]=j
  next

' preenche a paleta que falta
for i=palsz to 15
  opaletr[i]=opaletr[palsz-1]
  opaletg[i]=opaletg[palsz-1]
  opaletb[i]=opaletb[palsz-1]
  next

' cria realpal
for i=0 to 15:realpal[i]=i:next i

' copia a paleta de 3bit para 8bit
for i=0 to 15
  npaletg[i]=int((opaletg[i]*255)/7)
  npaletr[i]=int((opaletr[i]*255)/7)
  npaletb[i]=int((opaletb[i]*255)/7)
  next

'---- define palette grayscale 
for i=0 to 15
  gpal=opaletg[i]
  bpal=opaletb[i]
  rpal=opaletr[i]
  graypl[i]=((((bpal*11)+(rpal*30)+(gpal*59))*255)/700)
  next

' ---- colour count (important)
for i=0 to 15:clrcnt[i]=0:next i
for y1=0 to 23
  locate 24,2:setcaption(str$((y1*100)/23)+" - 1/2";
  for y2=0 to 7
    for xp=0 to 255
      y=(y1*8)+y2:iy=191-y:xh=int(xp/2)
      if bitdepth=8 then:
        ympos= imstart+1+xp+(iy*256): get #1, ympos
        tccnt=(asc(fb1$)) mod 16
        end if
      if bitdepth=4 then:
        ympos= imstart+1+xh+(iy*128): get #1, ympos
        u1=asc(fb1$): u2=x2 mod 2
        if u2=0 then:
          u3=240 : u4=16
          end if
        if u2=1 then:
          u3=15:u4=1
          end if
        tccnt= int((u1 and u3)/u4)
        end if
      clrcnt[i]=clrcnt[i]+tccnt
      next
    next
  next

'---- palette correction  (deve ser melhorado)
for j=0 to 16:for i=0 to 14
  if clrcnt[i]<clrcnt[i+1] then:
    swap graypl[i],graypl[i+1]
      swap realpal[i],realpal[i+1]
      swap clrcnt[i],clrcnt[i+1]
    swap opaletr[i],opaletr[i+1]
      swap opaletg[i],opaletg[i+1]
      swap opaletb[i],opaletb[i+1]
    swap npaletr[i],npaletr[i+1]
      swap npaletg[i],npaletg[i+1]
      swap npaletb[i],npaletb[i+1]
  end if 
  next:next
 
 
for j=0 to 8:for i=0 to 6
  if graypl[i]>graypl[i+1] then:
    swap graypl[i],graypl[i+1]
      swap realpal[i],realpal[i+1]
      swap clrcnt[i],clrcnt[i+1]
    swap opaletr[i],opaletr[i+1]
      swap opaletg[i],opaletg[i+1]
      swap opaletb[i],opaletb[i+1]
    swap npaletr[i],npaletr[i+1]
      swap npaletg[i],npaletg[i+1]
      swap npaletb[i],npaletb[i+1]
  end if 
 next i:next j
for j=0 to 8:for i=8 to 14
  if graypl[i]>graypl[i+1] then:
    swap graypl[i],graypl[i+1]
      swap realpal[i],realpal[i+1]
      swap clrcnt[i],clrcnt[i+1]
    swap opaletr[i],opaletr[i+1]
      swap opaletg[i],opaletg[i+1]
      swap opaletb[i],opaletb[i+1]
    swap npaletr[i],npaletr[i+1]
      swap npaletg[i],npaletg[i+1]
      swap npaletb[i],npaletb[i+1]
  end if 
 next i:next j

' criacao de realpal invertido
for i=0 to 15:invrp(realpal[i])=i:next i

' grava a paleta no .mb8
for i=0 to 15
  ympos= 54+1+(i*4)
  seek #3,ympos
     lset fb3$=chr$(npaletb[i])
     put #3
  seek #3,ympos+1
     lset fb3$=chr$(npaletg[i])
     put #3
  seek #3,ympos+2
     lset fb3$=chr$(npaletr[i])
     put #3
  next

'----writes samcoupe screen signature 
sampalheader:
data 0,17,34,127,255
   restore sampalheader
for i=0 to 4
   read c
  seek #2,1+6928+i:lset fb2$=chr$(c):put #2
  seek #2,1+6948+i:lset fb2$=chr$(c):put #2
next i

'----writes the palette into the sa1 binary bank 
for i=0 to 15
    opalb=opaletb[i]*2:opalg=opaletg[i]*2:opalr=opaletr[i]*2
        b2=int((opalb and 4)/4)
      r2=int((opalr and 4)/4)
      g2=int((opalg and 4)/4)
        g1=int((opalg and 2)/2)
        b3=int((opalb and 8)/8)
      r3=int((opalr and 8)/8)
      g3=int((opalg and 8)/8)
    opalsam=b2+(r2*2)+(g2*4)+(g1*8)+(b3*16)+(r3*32)+(g3*64)
  seek #2,1+6912+i:lset fb2$=chr$(opalsam):put #2
  seek #2,1+6932+i:lset fb2$=chr$(opalsam):put #2
next i

'----main loop 
for y1=0 to 23
  set caption(str$((y1*100)/23)+" - 2/2")
  for x1=0 to 31
    '----atribute reading and mounting
    for y2=0 to 7
      for i=0 to 15:celcnt[i]=0:next
      for x2=0 to 7
        y=(y1*8)+y2 
        xp=(x1*8)+x2: iy=191-y 
        xh=int(xp/2)
        if bitdepth=8 then:
          ympos= imstart+1+xp+(iy*256): get #1, ympos
          xpnt(x2,y2)=invrp((asc(fb1$)) mod 16)
          end if
        if bitdepth=4 then:
          ympos= imstart+1+xh+(iy*128): get #1, ympos
          u1=asc(fb1$): u2=x2 mod 2
          if u2=0 then:
            u3=240:u4=16
            end if
          if u2=1 then:
            u3=15:u4=1
            end if
          xpnt(x2,y2)=invrp( int((u1 and u3)/u4))
          end if
        u=xpnt(x2,y2)   
        celcnt(u)=celcnt(u)+1000+(rnd(99))
        next x2
      next y2

    ikattr=0:paattr=0:ikcnt=0:pacnt=0
    for i=0 to 15
      if ikcnt<celcnt[i] then:
        ikcnt=celcnt[i]:ikattr=i
        end if 
      next i

    celcnt(ikattr)=0
    for i=0 to 15
      if pacnt<celcnt[i] then:
        pacnt=celcnt[i]:paattr=i
        end if 
      next

    if ikattr<paattr then: swap ikattr,paattr: end if
    lumd=(graypl(ikattr)+graypl(paattr))/2
    iko=int(ikattr/8):pao=int(paattr/8)


    '- ve qual das 2 paletas a utilizar
    cntbr0=0
    for y2=0 to 7
      for x2=0 to 7
        if xpnt(x2,y2)<8 then:
          cntbr0=cntbr0+1
          end if
        next x2
      next y2
    brattr=0
    if cntbr0<32 then: brattr=1: end if

    if iko<>pao then:
      diptt=9999
      brok=(brattr*8)
      for i=0+brok to 7+brok
        disr=abs(npaletr[i]-npaletr(paattr))
        disg=abs(npaletg[i]-npaletg(paattr))
        disb=abs(npaletb[i]-npaletb(paattr))
        dist=sqr((disr^2)+(disg^2)+(disb^2))
        if dist<diptt and i<>paattrs then:
          diptt=dist:paattrn=i
          end if
            next
          paattr=paattrn
        end if

      '---- reading original 16 colour image as grayscale for screen 2 
      ik8=ikattr and 7:pa8=paattr and 7
      ik8pbr=ik8+(brattr*8):pa8pbr=pa8+(brattr*8)
      for y2=0 to 7
        pkvar=0
        for x2=0 to 7
          y=y2+(y1*8):x=x2+(x1*8):iy=191-y
          u=xpnt(x2,y2)
          ik=pa8pbr
            if graypl(u)>lumd then:
            ik=ik8pbr
            pkvar=pkvar+(2^(7-x2))
            end if 
          seek #3,123+(iy*256)+x:lset fb3$=chr$(ik):put #3
          next
        yq=((((y1 mod 24) and 24)*8)+(y2*8)+(y1 and 7))
        seek #2,1+x1+(yq*32):lset fb2$=chr$(pkvar):put #2
        next y2
      fb2t1=((ikattr*8) or (paattr) or (brattr*64))
      seek #2,1+6144+x1+(y1*32):lset fb2$=chr$(fb2t1):put #2
      next
    next

  close #1:close #2:close #3
  goto start


